The Ultimate Window Set -…Games & Quality Programs/The Ultimate Window Set - 250 Games & Quality Programs.iso/win/pro125/solii.cdl

Text File | 1993-09-22 | 6KB | 275 lines

//⌐ David Jean, 1993
game solII is 37 by 20;

//A1 A2 A3 A4 B1 B2 B3 B4 C1

{--------------------------------------------------------------------------}

procedure About is
begin
  Clear 'About Solitaire II';
  write('Rules from : ?.\n');
  write('Program : ⌐ David Jean, 1993.\n');
end;

stack A1;
stack A2;
stack A3;
stack A4;
stack B1;
stack B2;
stack B3;
stack B4;

{****c1 et c2 sont de meme sorte et c1 est un de plus que c2}
predicate Follow?(c1, c2 : card) is
  return ((c1 / 13)=(c2 / 13)) and (c1=(c2+1));

{****verifie si c1 est un roi}
predicate IsKing?(c1 : card) is
  return (c1 mod 13)=King;

{****verifie si c1 est un roi}
predicate IsAce?(c1 : card) is
  return (c1 mod 13)=Ace;

{****c1 est une carte tournee vers le bas}
predicate IsSideDown?(c1 : card) is
  return (c1 / DeckSize)=down;

predicate EmptySpot? is
begin
  with it do
    if it!=0 then return TRUE
  for A1, A2, A3, A4, B1, B2, B3, B4;
  return FALSE;
end;

predicate IsIn?(fs : stack; c1 : card) is
var i : integer;
begin
  i:=1;
  while i<=fs! do
    if fs[i]=c1 then
      begin
      flash fs[i];
      return TRUE;
      end
    else i:=i+1;
  return FALSE;
end;

predicate KingIsIn?(fs : stack) is
var i : integer;
    r : boolean;
begin
  //on commence a 2 parce qu'on s'en fout si un roi est le premier d'une pile
  i:=2;
  r:=FALSE;
  while i<=fs! do
    begin
    if not IsSideDown?(fs[i]) then
      if IsKing?(fs[i]) then
        begin
        flash fs[i];
        r:=TRUE;
        end;
    i:=i+1;
    end;
  return r;
end;

predicate Visible?(fs : stack; c1 : card) is
begin
  with it do
    if it<>fs then
      if IsIn?(it,c1) then return TRUE
  for A1, A2, A3, A4, B1, B2, B3, B4;
  return FALSE;
end;

predicate KingVisible?(fs : stack) is
var r : boolean;
begin
  r:=FALSE;
  with it do
    if it<>fs then
      if KingIsIn?(it) then r:=TRUE
  for A1, A2, A3, A4, B1, B2, B3, B4;
  return r;
end;

{--------------------------------------------------------------------------}

stack C1 is
  X := 34;
  Y := 2;
  Direction := over;
  W := 3;
  H := 4;
  //****************************
  Start is
    begin
    Add Ace+Spade .. King+Diamond;
    Turn [1..52] side down;
    Shuffle;
    end;
  //****************************
  Select(Spos : Index) is
  var movepossible : boolean;
    begin
    movepossible:=FALSE;
    with it do
      if (it!=0) and KingVisible?(it) then movepossible:=TRUE
      else if not IsAce?(it[it!]) and Visible?(it,it[it!]-1) then movepossible:=TRUE
    for A1, A2, A3, A4, B1, B2, B3, B4;
    if movepossible or (!=0) then break;
    with it do
      begin
      Pull 1 to it;
      Turn it[it!] side up;
      end
    for A1, A2, A3, A4;
    end;
  //****************************
  Help is
    begin
    Clear 'The Stock';
    Write('You can click here to move the four remaining cards to ');
    Write('the first four pile on The Tableau.\n');
    Write('It will work only if no move can be made on The Tableau.\n');
    Write('If there are legal moves, they will flash.\n');
    Wait 'About...' About;
    end;
end C1;

{--------------------------------------------------------------------------}

stack A1 is
  X := 2;
  Y := 2;
  Direction := down;
  W := 3;
  H := 18;
  //****************************
  Start is
    begin
    Pull 6 from C1;
    Turn [1..6] side up;
    Draw C1;
    end;
  //****************************
  Select(Spos : Index) is
    begin
    if Spos>! then Spos:=!;
    if IsSideDown?([Spos]) then break;
    if IsKing?([Spos]) then
      with it do
        if (it!=0) then
          begin
          Pull !-Spos+1 to it;
          break procedure;
          end
      for A1, A2, A3, A4, B1, B2, B3, B4
    else
      with it do
        if it<>self then
          if Follow?(it[it!],[Spos]) then
        begin
            Pull !-Spos+1 to it;
            break procedure;
            end
      for A1, A2, A3, A4, B1, B2, B3, B4;
    end;
  //****************************
  Help is
    begin
    Clear 'The Tableau';
    Write('Each card played here must be of the same suit and be in descending ');
    Write('sequence to the card on which it is played.\n');
    Write('You can pick a card anywhere on The Tableau (if it is side up).\n');
    Write('Every cards below the one you choose will move with it.\n\n');
    Write('Only kings can be moved in an empty spot.\n\n');
    Write('The goal is four piles of a unique suit beginning with The King and ending with The Ace.\n');
    Wait 'About...' About;
    end;
end A1;

stack A2 from A1 is
  X := 6;
  Y := 2;
end A2;

stack A3 from A1 is
  X := 10;
  Y := 2;
end A3;

stack A4 from A1 is
  X := 14;
  Y := 2;
end A4;

stack B1 from A1 is
  X := 18;
  Y := 2;
  //****************************
  Start is
    begin
    Pull 6 from C1;
    Turn [3..6] side up;
    Draw C1;
    end;
end B1;

stack B2 from B1 is
  X := 22;
  Y := 2;
end B2;

stack B3 from B1 is
  X := 26;
  Y := 2;
end B3;

stack B4 from B1 is
  X := 30;
  Y := 2;
end B4;

{--------------------------------------------------------------------------}

predicate inorder?(it : stack) is
var i : integer;
begin
  i:=13;
  while i>1 do
    begin
    if not Follow?(it[i-1],it[i]) then return FALSE;
    i:=i-1;
    end;
  return TRUE;
end;

predicate win? is
begin
  with it do
    if (it!=13) then
      if not inorder?(it) then return FALSE
      else
    else if (it!<>0) then return FALSE
  for A1, A2, A3, A4, B1, B2, B3, B4;
  return TRUE;
end;

predicate Integrity? is
begin
  with it do
    if it!>0 then
      if IsSideDown?(it[it!]) then
        Turn it[it!] side up
  for B1, B2, B3, B4;
  return TRUE;
end;

order C1, A1, A2, A3, A4, B1, B2, B3, B4.